home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
p063b9s.zip
/
UNIT
/
INPUT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-04-20
|
19KB
|
607 lines
UNIT Input;
{╔══════════════════════════════════════════════════════════════════════════╗}
{║ Diverse indtastnings, og sp¢rge-rutiner Last changed: 20.04.96 SA ║}
{║ ║}
{║ (C) Copyright 1989-95 by ║}
{║ Dan Wulff, Jens Sandalgaard, Steen Christensen & S¢ren Ager ║}
{║ ║}
{║ This source may not be given to anybody, without the written permission ║}
{║ from The Portal Team. ║}
{╚══════════════════════════════════════════════════════════════════════════╝}
{$I POPDEFS.INC}
INTERFACE
USES Use32, Dos, OpEntry, PoPTypes, RBrowser;
FUNCTION GetConfirmAddress(x,y: Byte; VAR Address: TFidoAddress; HelpTopic:WORD): Boolean;
FUNCTION GetAddress(Line, Col: Byte; VAR Address: TFidoAddress; HelpTopic:WORD): Boolean;
FUNCTION TestDirectoryPath(VAR Esr: EntryScreen; VAR Path: PathStr; AddBS:BOOLEAN): Boolean;
FUNCTION SelectFile(VAR FName: String): Boolean;
FUNCTION InputString(x,y,len,field,col:BYTE; CONST Head, Lead: STRING; VAR s:STRING): Boolean;
FUNCTION SelectPath(VAR Path: PathStr): Boolean;
FUNCTION Confirm(CONST s: String; Default: Char; y: Byte): Boolean;
FUNCTION ConfirmAll(CONST s: String; y: Byte): Char;
PROCEDURE MultiSelect(CONST Adr : TFidoAddress;
CONST Head : S40;
CONST Lead : S80;
CONST Ext : S3;
VAR Buf;
Siz : WORD;
VAR SendTo : SendToType;
GS : GetStrFuncType;
VAR Esr : EntryScreenPtr);
IMPLEMENTATION
USES OpCrt, OpWindow, OpCmd, OpFrame, OpField, OpDir, OpPick, OpEdit,
OpSelect, OpDos, OpString, OpKey,
Nodelist, MailUtil, Display, FileUtil, StrUtil, OproUtil,
Globals, NetFile, KeyBoard, Send2Utl;
TYPE
PDriveList = ^TDriveList;
TDriveList = ARRAY[1..26] OF Char;
PDrivePickList = ^TDrivePickList;
TDrivePickList = OBJECT(PickList)
DriveList : PDriveList;
CONSTRUCTOR Init(ADriveList: PDriveList; NumItems, Choice: Word);
PROCEDURE ItemString(Item: Word; Mode: pkMode; VAR IType: pkItemType; VAR IString: String); VIRTUAL;
END;
PPoPPathList = ^TPoPPathList;
TPoPPathList = OBJECT(PathList)
Wait : PWait;
CONSTRUCTOR InitCustom(X1, Y1, X2, Y2 : Byte;
var AColors : OpCrt.ColorSet;
Options : LongInt;
HeapToUse : LongInt;
PickOrientation : pkGenlProc;
CommandInit : paInitCommandProc);
PROCEDURE paFindPaths(Level: Byte; StartDir: PathStr); VIRTUAL;
END;
VAR
DL : DirListPtr;
FName1 : PathStr;
CONSTRUCTOR TDrivePickList.Init(ADriveList: PDriveList; NumItems, Choice: Word);
BEGIN
INHERITED InitAbstract(24, 5, 56, 20, Cfg.Color[2], DefWindowOptions+wBordered, 25, NumItems, PickVertical, SingleChoice);
SetSearchMode(PickCharSearch);
IF Cfg.Screen.ExplodingWin THEN EnableExplosions(10);
wFrame.AddShadow(shBR, shSeeThru);
wFrame.AddHeader('Disk',heTC);
SetInitialChoice(Choice);
DriveList:=ADriveList;
END;
PROCEDURE TDrivePickList.ItemString(Item: Word; Mode: pkMode; VAR IType: pkItemType; VAR IString: String);
{ VAR
MediaID : MediaIdType;}
BEGIN
{ IF GetMediaID(DriveList^[Item], MediaID)=0 THEN}
IString:=DriveList^[Item]+': '+GetDiskString(DriveList^[Item]);
{ ELSE
IString:=DriveList^[Item]+': Drive not ready';}
IF Mode=pkDisplay THEN IString:=' '+IString+' ';
END;
{=== TPoPPathList ===}
CONSTRUCTOR TPoPPathList.InitCustom(X1, Y1, X2, Y2 : Byte;
VAR AColors : OpCrt.ColorSet;
Options : LongInt;
HeapToUse : LongInt;
PickOrientation : pkGenlProc;
CommandInit : paInitCommandProc);
BEGIN
IF NOT INHERITED InitCustom(X1, Y1, X2, Y2, AColors, Options, HeapToUse,
PickOrientation, CommandInit) THEN Fail;
Wait:=NIL;
END;
PROCEDURE TPoPPathList.paFindPaths(Level: Byte; StartDir: PathStr);
BEGIN
IF Wait<>NIL THEN Wait^.Animate;
INHERITED paFindPaths(Level, StartDir);
END;
{=== ===}
PROCEDURE MultiSelect(CONST Adr : TFidoAddress;
CONST Head : S40;
CONST Lead : S80;
CONST Ext : S3;
VAR Buf;
Siz : WORD;
VAR SendTo : SendToType;
GS : GetStrFuncType;
VAR Esr : EntryScreenPtr);
VAR
w:WindowPtr;
OldTopic,InKey:WORD;
Max,y,Top:Integer;
f : TNetFile;
PROCEDURE WriteLine(y:BYTE; Num:WORD; Current,Toggle:BOOLEAN);
VAR
s:STRING;
Marked:BOOLEAN;
Cnt:BYTE;
st:SendToTabType;
BEGIN
DEC(Num);
IF Num<f.FileSize THEN
BEGIN
f.GetRec(Buf,Num,NoKeep,Wait);
ReadSendTo(SendTo,st,Cnt);
Marked:=IsSendingTo(Adr,St,Cnt);
IF Toggle THEN
BEGIN
IF Marked THEN RemoveFromSendTo(Adr,st,Cnt) ELSE AddToSendTo(Adr,st,Cnt);
WriteSendTo(st,SendTo,Cnt);
Marked:=NOT Marked;
f.PutRec(Buf,Num);
END;
s:=GS(Buf, f);
END ELSE
BEGIN
s:='';
Marked:=FALSE;
Current:=FALSE;
END;
w^.wFastWrite(CPad(s,78),y+1,1,CorrectAttribute(3,Current,Marked));
END;
PROCEDURE WritePage(Num:WORD);
VAR
i:WORD;
BEGIN
FOR i:=1 TO ScreenHeight-4 DO
WriteLine(i,Num+i,FALSE,FALSE);
Max:=f.FileSize-Top;
IF Max>ScreenHeight-4 THEN Max:=ScreenHeight-4;
IF y>Max THEN y:=Max;
END;
PROCEDURE MoveDown(Num:Integer);
VAR
i,OldTop:Integer;
BEGIN
OldTop:=Top;
FOR i:=1 TO Num DO
IF y<Max THEN INC(y) ELSE
IF Max+Top<f.FileSize THEN INC(Top);
IF OldTop<>Top THEN WritePage(Top);
END;
PROCEDURE MoveUp(Num:Integer);
VAR
i,OldTop:Integer;
BEGIN
OldTop:=Top;
FOR i:=1 TO Num DO
IF y>1 THEN DEC(y) ELSE
IF Top>0 THEN DEC(Top);
IF Top<>OldTop THEN WritePage(Top);
END;
BEGIN
MyWin(w,1,2,ScreenWidth,ScreenHeight,3,Head,FALSE);
w^.wFastText(CPad(Lead,78),1,1);
f.Open(StartPath+'PORTAL.'+Ext,Siz,TRUE);
IF f.FileSize>0 THEN
BEGIN
OldTopic:=Topic;
Topic:=950;
y:=1;
Top:=0;
WritePage(Top);
REPEAT
WriteLine(y,y+Top,TRUE,FALSE);
InKey:=PoPReadKeyWord;
WriteLine(y,y+Top,FALSE,FALSE);
CASE InKey OF
Home : BEGIN
Top:=0;
y:=1;
WritePage(Top);
END;
Up : MoveUp(1);
PgUp : MoveUp(ScreenHeight-3);
Down : MoveDown(1);
PgDn : MoveDown(ScreenHeight-3);
EndKey : BEGIN
Top:=f.FileSize-(ScreenHeight-4);
IF Top<0 THEN Top:=0;
WritePage(Top);
y:=Max;
END;
Enter : BEGIN
WriteLine(y,y+Top,FALSE,TRUE);
MoveDown(1);
END;
END;
UNTIL InKey=Esc;
Topic:=OldTopic;
END;
f.Close;
KillWindow(w);
Esr^.SetNextField(Esr^.GetCurrentID);
Esr^.SetLastCommand(ccNone);
END;
FUNCTION GetConfirmAddress(x,y: Byte; VAR Address: TFidoAddress; HelpTopic:WORD): Boolean;
VAR
Ok,GotIt : Boolean;
NRec : NodeListRecType;
OldTopic : WORD;
N : TNodeInfo;
BEGIN
OldTopic:=Topic;
Topic:=HelpTopic;
REPEAT
GotIt:=GetAddress(x,y,Address,Topic);
RemapAddress(Address);
IF GotIt THEN
IF FindNode(Address,NRec) THEN
BEGIN
Ok:=Confirm('Node is: "'+NRec.SystemName+'", correct?','Y',12);
END ELSE
BEGIN
Ok:=FindNodeInfo(N,Address);
IF NOT ok THEN
Ok:=Confirm('Node : '+Address2Str(Address)+' is unknown, ok?','Y',12);
END;
UNTIL Not GotIt or Ok;
Topic:=OldTopic;
GetConfirmAddress:=GotIt;
END;
FUNCTION GetAddress(Line, Col: Byte; VAR Address: TFidoAddress; HelpTopic:WORD): Boolean;
VAR
ESr : TPoPEntryScreen;
OldTopic:WORD;
BEGIN
OldTopic:=Topic;
WITH Esr, Address DO
BEGIN
Esr.Init(33, Line+1, 46, line+4, Col, 'Node');
{$IFDEF OS2}
addsmallintfield('Zone :',1,2,'#####',1,9,HelpTopic,0,0,Zone);
addsmallintfield('Net :',2,2,'#####',2,9,HelpTopic,0,0,Net);
addsmallintfield('Node :',3,2,'#####',3,9,HelpTopic,0,0,Node);
addsmallintfield('Point:',4,2,'#####',4,9,HelpTopic,0,0,Point);
{$ELSE}
addintfield('Zone :',1,2,'#####',1,9,HelpTopic,0,0,Zone);
addintfield('Net :',2,2,'#####',2,9,HelpTopic,0,0,Net);
addintfield('Node :',3,2,'#####',3,9,HelpTopic,0,0,Node);
addintfield('Point:',4,2,'#####',4,9,HelpTopic,0,0,Point);
{$ENDIF}
SetNextField(2);
REPEAT
Process;
UNTIL (GetLastCommand=ccQuit) Or Not CmpAdr(Address,Cfg.Addresses[Cfg.MainAdrNum]);
GetAddress:=(ESR.GetLastCommand<>ccQuit);
END;
Esr.Done;
Topic:=OldTopic;
END;
FUNCTION TestDirectoryPath(VAR Esr: EntryScreen; VAR Path: PathStr; AddBS:BOOLEAN): Boolean;
VAR
Save : Boolean;
Dir : PathStr;
BEGIN
Save:=False;
IF (Esr.GetLastCommand=ccUser2) AND SelectPath(Path) THEN Save:=True;
IF (Path<>'') THEN
BEGIN
IF Copy(Path,2,1)<>':' THEN
BEGIN
GetDir(0, Dir);
IF Copy(Path, 1, 1)='\' THEN Path:=Copy(Dir, 1, 2)+Path ELSE Path:=Dir+'\'+Path;
Esr.DrawField(Esr.GetCurrentID);
END;
IF NOT ChkDir(Path) THEN
IF (Confirm('Directory does not exist, create it?','Y',11)) THEN
BEGIN
Save:=True;
MakeFullDir(Path);
END ELSE
BEGIN
Esr.SetNextField(Esr.GetCurrentID);
Esr.SetLastCommand(ccNone);
END;
IF (AddBS OR ((Length(Path)=2) AND (Path[2]=':'))) THEN
BEGIN
IF (Path[Length(Path)]<>'\') THEN
BEGIN
Path:=Path+'\';
Esr.DrawField(Esr.GetCurrentID);
Save:=True;
END;
END ELSE
BEGIN
IF (Length(Path)>3) THEN
BEGIN
IF (Path[Length(Path)]='\') THEN
BEGIN
Dec(Path[0]);
Esr.DrawField(Esr.GetCurrentID);
Save:=True;
END;
END;
END;
END;
TestDirectoryPath:=Save;
END;
FUNCTION InputString(x, y, Len, Field, Col: Byte; CONST Head, Lead: STRING; VAR s: STRING): Boolean;
VAR
le:LineEditor;
temp:WindowPtr;
BEGIN
WITH le DO
BEGIN
mywin(Temp,x,y,x+field+4+Length(lead),y+2,col,Head,True);
WITH le DO
BEGIN
Init(Cfg.Color[col]);
leEditOptionsOff(leTrimBlanks);
ReadString(Lead, y+1,x+2+(ScreenWidth-80) DIV 2, len, field, s);
TrimTrail(s);
InputString:=NOT (GetLastCommand=ccQuit);
Done;
END;
KillWindow(Temp);
END;
END;
procedure PreEdit(ESP : EntryScreenPtr); far;
{-Called just before a field is edited}
begin
with ESP^ do
if GetCurrentID = 1 then
if DL^.GetMatchingFileCount = 0 then
SetNextField(0);
end;
procedure PostEdit(ESP : EntryScreenPtr); far;
function AcceptFile(var S : string) : Boolean;
begin
S:=FExpand(S);
if (S[Length(S)] = '\') or IsDirectory(S) then
begin
S:=AddBackSlash(S)+'*.*';
AcceptFile := False;
end else
AcceptFile:=(ExistFile(S) And (Pos('*',s)=0) And (Pos('?',s)=0));
end;
begin
with ESP^ do
case GetCurrentID of
0 : if (GetLastCommand = ccSelect) and AcceptFile(FName1) then
SetLastCommand(ccDone)
else
if CurrentFieldModified then
begin
DL^.SetMask(FExpand(FName1), AnyFile);
ChDir(JustPathName(FName1));
DL^.PreLoadDirList;
Draw;
end;
1 : if GetLastCommand = ccSelect then
begin
FName1 := DL^.GetSelectedPath;
ChDir(JustPathName(FName1));
DrawField(0);
end;
end;
end;
FUNCTION SelectFile(VAR FName: String): Boolean;
var
ES : EntryScreen;
Status : Word;
AllDone : Boolean;
CurDir : PathStr;
function InitEntryScreen : Word;
const
WinOptions = wBordered+wClear+wUserContents;
begin
with ES do
begin
if not InitCustom(6, 6, 74, 21, Cfg.Color[3], WinOptions) then
begin
InitEntryScreen := $ffff;
Exit;
end;
wFrame.AddShadow(shBR, shSeeThru);
SetWrapMode(WrapAtEdges);
SetPreEditProc(PreEdit);
SetPostEditProc(PostEdit);
esFieldOptionsOn(efClearFirstChar);
AddSimpleStringField('File:', 1, 3, 'X', 1, 9, 50, 64, 1, FName1);
esFieldOptionsOff(efAllowEscape);
esSecFieldOptionsOn(sefSwitchCommands);
AddWindowField('', 2, 3, 2, 3, 2, DL^);
InitEntryScreen := RawError;
end;
end;
function InitDirList : Word;
const
WinOptions = wBordered+wAltFrame+wClear+wUserContents+wNoCoversBuffer;
begin
New(DL, InitCustom(9, 8, 71, 20, Cfg.Color[3], WinOptions, MaxAvail-8192, PickHorizontal, SingleFile));
if DL=NIL then
begin
InitDirList := $ffff;
Exit;
end;
with DL^ do
begin
DL^.AddMaskHeader(True, 1, Width, heTC);
DL^.AddMoreHeader(' || ', heBR, #25, #24, '', 2, 3, 0);
{ aFrame.SetFrameAttr($1B, $07);}
SetPadSize(1,1);
SetSortOrder(SortDirName);
diOptionsOn(diShowDrives+diExitIfOne+diSetFirstFile);
SetNameSizeKFormat('<dir>');
SetSearchMode(PickStringSearch);
SetDriveDelim('[',':\]');
SetMask(FName1, AnyFile);
PreLoadDirList;
InitDirList:=RawError;
end;
end;
begin
SelectFile:=False;
GetDir(0, CurDir);
FName1:=FExpand(FName);
Status:=InitDirList;
if Status <> 0 then
begin
WriteLn('Error initializing DirList: ', Status);
Exit;
end;
Status := InitEntryScreen;
if Status <> 0 then
begin
WriteLn('Error initializing entry screen: ', Status);
Exit;
end;
AllDone := False;
repeat
ES.Process;
case ES.GetLastCommand of
ccDone : AllDone := True;
ccError,
ccQuit : begin
AllDone := True;
FName1 := '';
end;
end;
until AllDone;
ES.Erase;
SelectFile:=ES.GetlastCommand<>ccQuit ;
IF ES.GetLastCommand<>ccQuit THEN FName:=FName1;
ES.Done;
ChangeDir(CurDir);
end;
FUNCTION SelectDrive(VAR InDrive: Char): Boolean;
VAR
DriveList : TDriveList;
PL : TDrivePickList;
i, ii : Word;
Drive : Char;
BEGIN
FillChar(DriveList, SizeOf(DriveList), 0);
i:=1; ii:=1;
FOR Drive:='A' TO 'Z' DO
IF ValidDrive(Drive) THEN
BEGIN
DriveList[i]:=Drive;
IF InDrive=Drive THEN ii:=i;
Inc(i);
END;
PL.Init(@DriveList, Pred(i), ii);
PL.Process;
PL.Erase;
IF PL.GetLastCommand=ccSelect THEN InDrive:=DriveList[PL.GetLastChoice]
ELSE InDrive:=DefaultDrive;
SelectDrive:=(PL.GetLastCommand=ccSelect);
PL.Done;
END;
FUNCTION SelectPath(VAR Path: PathStr): Boolean;
VAR
TmpPath : PathStr;
PL : TPoPPathList;
Drive : Char;
Win : WindowPtr;
BEGIN
WITH PL DO
BEGIN
IF Not InitCustom(25,4,55,19,Cfg.Color[3],DefWindowOptions+wBordered,
MaxAvail-1024, PickVertical, SinglePath) THEN
BEGIN
SelectPath:=False;
END;
IF Cfg.Screen.ExplodingWin THEN EnableExplosions(10);
wFrame.Addheader(' Select Directory ',heTC);
wFrame.AddShadow(shBR, shSeeThru);
paOptionsOn(paAltCurDir+paUpcase+paOptimizeSize+paSetCurDir);
SetPadSize(1,1);
IF ((Length(Path)>0)) And (ValidDrive(Path[1])) THEN
Drive:=Path[1] ELSE Drive:=DefaultDrive;
IF SelectDrive(Drive) THEN
BEGIN
New(Wait, Init((ScreenHeight DIV 2)-2, 1, 'Scanning drive '+Drive+':'));
SetDrive(Drive);
PreloadPathList;
TmpPath:=GetPathName(Drive);
Dispose(Wait, Done); Wait:=NIL;
END ELSE
TmpPath:='';
IF TmpPath<>'' THEN
BEGIN
Path:=TmpPath;
SelectPath:=(GetLastCommand=ccSelect);
END ELSE
SelectPath:=False;
Done;
END;
END;
FUNCTION Confirm(CONST s: String; Default: Char; y: Byte): Boolean;
VAR
x : Byte;
ConfirmWin : WindowPtr;
LE : LineEditor;
BEGIN
x:=38-(Length(s) DIV 2);
mywin(ConfirmWin,x-2,y,x+7+Length(s),y+2,3,'Confirm',True);
LE.Init(Cfg.Color[3]);
Confirm:=LE.YesOrNo(s,y+1,x+((ScreenWidth-80) DIV 2),default);
KillWindow(ConfirmWin);
END;
FUNCTION ConfirmAll(CONST s: String; y: Byte): Char;
VAR
x : Byte;
ConfirmWin : WindowPtr;
LE : LineEditor;
Ch : Char;
BEGIN
x:=38-((Length(s)+8) DIV 2);
mywin(ConfirmWin,x-2,y,x+10+Length(s),y+2,3,'Confirm',True);
LE.Init(Cfg.Color[3]);
LE.ReadChar(s+' (y/n/a) ', y+1,x+((ScreenWidth-80) DIV 2), ['Y','y','N','n','A','a'], Ch);
ConfirmAll:=UpCase(Ch);
KillWindow(ConfirmWin);
END;
END.